Attribute VB_Name = "EncodeURL"
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function ApiEmptyByteArray Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal VarType As VbVarType = vbByte, Optional ByVal Low As Long = 0, Optional ByVal Count As Long = 0) As Byte()

Public Enum CodePage
    CP_UTF8 = 65001
    CP_GBK = 936
    CP_ACP = 0
End Enum

Public Enum UnEncodedMode
    UnEncodeURI = 0
    UnEncodeURIComponent = 1
End Enum

Public Const UnEncodeURIStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!#$&'()*+,-./:;=?@_~"
Public Const UnEncodeURIComponentStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789!'()*-._~"

Public Function EncodeURI(ByVal s As String, Optional ByVal lCodePage As CodePage = CP_UTF8, Optional ByVal UnEnMode As UnEncodedMode = UnEncodeURIComponent) As String
    Dim i As Long
    Dim lLength As Long
    Dim lBufferSize As Long
    Dim lResult As Long
    Dim abData() As Byte
    Dim AllEncodeURI() As String
    Dim UnEncoded As String
    
    EncodeURI = ""
    lLength = Len(s)
    If lLength = 0 Then Exit Function
    
    
    If UnEnMode = UnEncodeURIComponent Then
        UnEncoded = UnEncodeURIComponentStr
    Else
        UnEncoded = UnEncodeURIStr
    End If
    
    lBufferSize = lLength * 3 + 1
    ReDim abData(lBufferSize - 1)
    lResult = WideCharToMultiByte(lCodePage, 0, StrPtr(s), lLength, abData(0), lBufferSize, vbNullString, 0)
    
    If lResult <> 0 Then
        lResult = lResult - 1
        ReDim Preserve abData(lResult)
        ReDim Preserve AllEncodeURI(lResult)
        Dim lStart As Long
        Dim lEnd As Long
        Dim CheckByteChr As String
        
        lStart = LBound(abData)
        lEnd = UBound(abData)
        
        For i = lStart To lEnd
            CheckByteChr = ChrW(abData(i))
            If InStrB(UnEncoded, CheckByteChr) > 0 Then
                AllEncodeURI(i) = CheckByteChr
            Else
                If abData(i) = 13 Or abData(i) = 10 Then
                    AllEncodeURI(i) = "%0A"
                Else
                    AllEncodeURI(i) = "%" & Hex$(abData(i))
                End If
            End If
        Next
        EncodeURI = Join(AllEncodeURI, "")
    End If
End Function
Public Function DecodeURI(ByVal s As String, Optional ByVal lCodePage As CodePage = CP_UTF8, Optional ByVal UnEnMode As UnEncodedMode = UnEncodeURIComponent) As String
    ' On Error Resume Next
    Dim lRet As Long
    Dim lLength As Long
    Dim sL As Long
    Dim sDecode As String
    Dim lBufferSize As Long
    Dim abData() As Byte
    Dim i As Long
    Dim v() As String
    'v = Split(s, "%")
    Call FastSplit(s, v, "%")
    
    lLength = UBound(v)
    
    If lLength <= 0 Then
        DecodeURI = s
        Exit Function
    End If
    
    DecodeURI = v(0)
    sL = -1
    
    
    For i = 1 To lLength
        
        If Len(v(i)) = 2 Then
            sL = sL + 1
            ReDim Preserve abData(sL)
            abData(sL) = CByte("&H" & v(i))
        Else
            sL = sL + 1
            ReDim Preserve abData(sL)
            abData(sL) = CByte("&H" & Left$(v(i), 2))
            lBufferSize = (sL + 1) * 2
            sDecode = String$(lBufferSize, Chr$(0))
            lRet = MultiByteToWideChar(lCodePage, 0, VarPtr(abData(0)), sL + 1, StrPtr(sDecode), lBufferSize)
            If lRet <> 0 Then DecodeURI = DecodeURI & Left$(sDecode, lRet)
            sL = -1
            sDecode = ""
            DecodeURI = DecodeURI & Right$(v(i), Len(v(i)) - 2)
            Erase abData
        End If
        
    Next
    
    If sL > 0 Then
        lBufferSize = (sL + 1) * 2
        sDecode = String$(lBufferSize, Chr$(0))
        lRet = MultiByteToWideChar(lCodePage, 0, VarPtr(abData(0)), sL + 1, StrPtr(sDecode), lBufferSize)
        If lRet <> 0 Then DecodeURI = DecodeURI & Left$(sDecode, lRet)
    End If
    
End Function
Public Function ToCodeArray(sText As String, Optional ByVal lCodePage As CodePage = CP_UTF8) As Byte()
    Dim baRetVal()   As Byte
    Dim lSize  As Long
    
    lSize = WideCharToMultiByte(lCodePage, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
    If lSize > 0 Then
        ReDim baRetVal(0 To lSize - 1) As Byte
        Call WideCharToMultiByte(lCodePage, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
    Else
        baRetVal = ApiEmptyByteArray
    End If
    ToCodeArray = baRetVal
End Function
Public Function FromlCodeArray(baText() As Byte, Optional ByVal lCodePage As CodePage = CP_UTF8) As String
    Dim lSize           As Long
    
    FromlCodeArray = String$(2 * UBound(baText), 0)
    lSize = MultiByteToWideChar(lCodePage, 0, VarPtr(baText(0)), UBound(baText) + 1, StrPtr(FromlCodeArray), Len(FromlCodeArray))
    If lSize <> 0 Then FromlCodeArray = Left$(FromlCodeArray, lSize)
End Function
Public Function FastJoin(sArray() As String, Optional Delimiter As String = " ") As String
    Dim c&, iLen&, iCurPos&, nChars&, iLo&, iHi&, nEmptyStr&
    iLo = LBound(sArray)
    iHi = UBound(sArray)
    For c = iHi To iLo Step -1
        nChars = Len(sArray(c))
        iLen = iLen + nChars
        If nChars = 0 Then nEmptyStr = nEmptyStr + 1 Else Exit For
    Next c
    For c = iLo To iHi - nEmptyStr - 1
        iLen = iLen + Len(sArray(c))
    Next c
    
    nChars = Len(Delimiter)
    iLen = iLen + (iHi - iLo) * nChars
    If iLen Then
        FastJoin = Space$(iLen)
        
        Mid$(FastJoin, 1) = sArray(iLo)
        iCurPos = Len(sArray(iLo)) + 1
        
        If nChars Then
            For c = iLo + 1 To iHi - nEmptyStr
                Mid$(FastJoin, iCurPos, nChars) = Delimiter
                iCurPos = iCurPos + nChars
                
                Mid$(FastJoin, iCurPos, iLen) = sArray(c)
                iCurPos = iCurPos + Len(sArray(c))
            Next c
            For c = iCurPos To iLen Step nChars
                Mid$(FastJoin, c, nChars) = Delimiter
            Next c
        Else
            For c = iLo + 1 To iHi - nEmptyStr
                Mid$(FastJoin, iCurPos, iLen) = sArray(c)
                iCurPos = iCurPos + Len(sArray(c))
            Next c
        End If
    End If
End Function

Public Sub FastSplit(Expression$, ResultSplit$(), Optional Delimiter$ = " ")
    Dim c&, SLen&, DelLen&, tmp&, Results&()
    
    SLen = LenB(Expression) \ 2
    DelLen = LenB(Delimiter) \ 2
    
    If SLen = 0 Or DelLen = 0 Then
        ReDim Preserve ResultSplit(0 To 0)
        ResultSplit(0) = Expression
        Exit Sub
    End If
    
    ReDim Preserve Results(0 To SLen)
    tmp = InStr(Expression, Delimiter)
    
    Do While tmp
        Results(c) = tmp
        c = c + 1
        tmp = InStr(Results(c - 1) + 1, Expression, Delimiter)
    Loop
    
    ReDim Preserve ResultSplit(0 To c)
    
    If c = 0 Then
        ResultSplit(0) = Expression
    Else
        ResultSplit(0) = Left$(Expression, Results(0) - 1)
        For c = 0 To c - 2
            ResultSplit(c + 1) = Mid$(Expression, _
            Results(c) + DelLen, _
            Results(c + 1) - Results(c) - DelLen)
        Next c
        ResultSplit(c + 1) = Right$(Expression, SLen - Results(c) - DelLen + 1)
    End If
End Sub

